#!/usr/bin/perl -w
package Rollout;
use Data::Dumper;
use Digest::MD5 qw/md5_hex/;
use POSIX qw/setsid/;
use File::Temp qw/tmpnam/;
use Fcntl qw/:flock/;
use Carp qw/confess/;
use vars qw/$safe_mode $safe_write_msg $log_fd $log_messages/;
use vars qw/$VERSION @ISA @EXPORT_OK %EXPORT_TAGS/;
use strict;

require Exporter;

@ISA = qw(Exporter);

$VERSION = "dummy";

@EXPORT_OK = qw(
    comma_or_arrayref in_path slurp_file set_attr dir_check
    command safe_write text_install file_install file_append
    file_comment file_uncomment file_modify symlink_check
    x509_cert x509_install dir_install exclusive_lock
    queue_command run_queued_commands reload_service
);

%EXPORT_TAGS = (all => \@EXPORT_OK);

$safe_mode = 0;
$safe_write_msg = "Changed by $0";
$log_fd = undef;
$log_messages = "";

END { run_queued_commands(); }

sub dir_check;
sub dir_install;
sub file_install;

sub classes
{
    my ($m, $start, $_seen) = @_;
    return unless $m->{$start}{ISA};
    $_seen ||= {};
    print "classes(\$m, $start, {".join(", ", map "$_=$_seen->{$_}", sort keys %{$_seen})."})\n"
	if $ENV{DEBUG};
    my @keys = grep !$_seen->{$_}++,
	ref $m->{$start}{ISA} eq 'ARRAY' ? @{ $m->{$start}{ISA} } :
	ref $m->{$start}{ISA} eq 'HASH'  ? sort keys %{ $m->{$start}{ISA} } : ();
    push @keys, classes($m, $_, $_seen)
	foreach @keys;
    return @keys;
}

sub in_class
{
    my ($m, $start, $key) = @_;

    return grep $_ eq $key, classes($m, $start);
}

sub add_class
{
    my ($m, $start, $class, $conf) = @_;

    unless (grep $_ eq $class, classes($m, $start))
    {
	for ($m->{$start}{ISA} ||= [])
	{
	    unshift @{ $_ }, $class if ref eq 'ARRAY';
	    $_->{$class} = 1 if ref eq 'HASH';
	}
    }

    $m->{$class} = $conf if $conf;
}

sub type_list
{
    my ($m, $key) = @_;

    return
	sort
	grep fetch_val($m, $_, $key),
	grep /^[a-z]/,
	keys %{ $m };
}

sub fetch_val
{
    my ($m, $start, $key) = @_;

    foreach my $class ($start, classes($m, $start))
    {
	return $m->{$class}{$key}
	    if exists $m->{$class}{$key};

	return $m->{$class}{ISA}{$key}
	    if ref $m->{$class}{ISA} eq 'HASH' and $m->{$class}{ISA}{$key};

	return 1
	    if ref $m->{$class}{ISA} eq 'ARRAY' and grep($_ eq $key, @{ $m->{$class}{ISA} });
    }
}

sub fetch_all
{
    my ($m, $start, $key) = @_;

    grep defined, map $m->{$_}{$key}, $start, classes($m, $start);
}

sub fetchall_array
{
    my ($m, $start, $key) = @_;

    my @ret;

    foreach my $got (grep defined, map $m->{$_}{$key}, $start, classes($m, $start))
    {
	confess sprintf "Unexpected type: \$m->{$start}{$key} = %s, should be SCALAR or ARRAY\n", ref $got
	    unless ref $got eq '' or ref $got eq 'ARRAY';

	push @ret, ref $got ? @$got : $got;
    }

    wantarray ? @ret : \@ret;
}

sub fetchall_hash
{
    my ($m, $start, $key, @sub) = @_;

    my %ret;
    my @order;

    foreach my $got (grep defined, map $m->{$_}{$key}, $start, classes($m, $start))
    {
	my @copy = @sub;

	do {
	    confess sprintf "Unexpected type: \$m->{$start}{$key} = %s, should be HASH\n", ref $got
		unless ref $got eq 'HASH';

	    $got = $got->{shift @copy} if @copy;
	} while @copy;

	$ret{$_} = $got->{$_}, push @order, $_
	    foreach grep !exists $ret{$_}, keys %{ $got };
    }

    return unless @order;
    wantarray ? (\%ret, \@order) : \%ret;
}

sub _args
{
    my ($order, @args) = @_;

    $order = [ map [ split /\|/, $_ ], split " ", $order ];

    my %pos;
    my $pos = 0;

    foreach my $item (@$order)
    {
	$pos{ lc $_ } = $pos foreach @$item;
	$pos++;
    }

    my @process;

    print STDERR "Caller: ".(caller 1)[3]."(".join(",", map +(ref) ? "[@$_]" : $_, @$order).")\n"
	if $ENV{DEBUG};
    print STDERR Dumper(\@args) if ($ENV{DEBUG} || 0) > 1;

    for (my $i = 0; $i < @args; $i++)
    {
	my $arg = $args[$i];

	if (ref $arg eq 'HASH')
	{
	    push @process, %{ $arg };
	}
	elsif ($arg =~ /^-/)
	{
	    push @process, $arg, $args[++$i];
	}
	elsif ($i < @$order)
	{
	    push @process, (ref $order->[$i] ? $order->[$i][0] : $order->[$i]), $arg;
	}
	else
	{
	    confess "Non-named arg after maximum positional\n";
	}
    }

    my @ret;
    $#ret = $#{$order}; # presize array
    my %leftover;

    while (my ($key, $val) = splice(@process, 0, 2))
    {
	($key = lc $key) =~ s/^-//;

	if (exists $pos{$key})
	{
	    $ret[ $pos{$key} ] = $val;
	}
	else
	{
	    $leftover{$key} = $val;
	}
    }

    @ret, \%leftover;
}

sub md5_hex_file
{
    my $file = shift;

    open my $tmp, "<", $file or return '';
    my $ret = Digest::MD5->new->addfile($tmp)->hexdigest;
    close $tmp;

    $ret;
}

sub comma_or_arrayref
{
    return
	map split(/\s*,\s*/, $_),
	map +(ref) ? @$_ : $_,
	grep defined, @_;
}

sub in_path
{
    return
	grep -x,
	map "$_/$_[0]",
	split /:/, $ENV{PATH};
}

sub exclusive_lock
{
    open my $fd, ">", shift || do { local $_ = $0; s!.*/!!; s/\.pl$//; "/var/lock/$_" };
    flock $fd, LOCK_EX|LOCK_NB or return;
    $fd;
}

sub note_asis
{
    print $log_fd $_[0] if $log_fd;
    $log_messages .= $_[0];
}

sub note
{
    my $fmt = shift;
    $fmt =~ s/\n*$/\n/;
    note_asis sprintf $fmt, @_;
}

sub warning
{
    note "WARN: ".shift(), @_;
}

sub command
{
    my $flags = {};
    $flags = pop @_ if ref $_[-1] eq 'HASH';

    return if $safe_mode and not $flags->{readonly};

    my $command = join " ", @_;
    $flags->{intro} ||= '';
    $flags->{failure} ||= "FAILED: '$command' failed.";
    $flags->{success} ||= "Finished running '$command'.";
    $flags->{timeout} = undef unless $flags->{timeout};

    note $flags->{intro} if $flags->{intro};

use IO::File;
use IO::Select;
    my $cmd = IO::File->new;
    my $child = $cmd->open('-|');
    unless ($child)
    {
        confess "SCREAM: Can't fork in command: $!" unless defined $child;

        $SIG{PIPE} = 'IGNORE';

        # detach from controlling tty
        setsid;
        open STDIN, '</dev/null';
        open(STDERR, '>&STDOUT');
        # XXX: close fd's 3:1024

        exec @_;
        die "SCREAM: Can't execute " . join (" ", @_) . ": $!\n";
    }

    local $_;
    my $timed_out = 1;
    my $out = length $flags->{intro};
    my $nl = $flags->{intro} =~ /\n$/;

    my $s = IO::Select->new($cmd);
    while ($s->can_read($flags->{timeout}))
    {
        unless ($cmd->sysread($_, 1024))
        {
            $timed_out = 0;
            last;
        }

	$_ = join "\n", grep !/$flags->{ignore}/, split /\n/, $_
	    if $flags->{ignore};

	next unless length;

        note_asis "CMD: " if $nl or !$out;
        s/\n(?=.)/\nCMD: /g;
        note_asis $_;

        $out += length;
        $nl = /\n$/;
    }

    if ($timed_out)
    {
        note "[timeout]\n";
        kill 15, $child;
    }
    else
    {
        note "\n" if $out and !$nl;
    }

    $cmd->close;
    if ($? >> 8) {
        note $flags->{failure} . "  Exit code: " . ($? >> 8) . "\n"
    }
    elsif ($?) {
        note $flags->{failure} . "  Signal: " . ($? & 0x7f) . "\n"
    }
    elsif ($out and not exists $flags->{intro}) {
        note $flags->{success} . "\n";
    }

    ## emulate a return of system()
    return $?;
}

QUEUE_SCOPE: {
    my @queue;
    my %seen;

    sub queue_command
    {
	push @queue, \@_
	    unless $seen{ "@_" }++;
    }

    sub run_queued_commands
    {
	command @$_ foreach @queue;
	@queue = ();
	%seen = ();
    }
}

sub reload_service
{
    foreach my $serv (map comma_or_arrayref($_), @_)
    {
	queue_command "service $serv condrestart"
	    if -e "/etc/init.d/$serv";
    }
}

sub slurp_file
{
    my ($src, $other) = _args('src|source', @_)
	or return;

    my $fd;

    if ($src =~ m|^https?://|)
    {
	if (in_path('wget'))
	{
	    open $fd, "-|" or exec "wget", "--no-check-certificate", "-qO-", $src;
	}
	elsif (in_path('curl'))
	{
	    open $fd, "-|" or exec "curl", "--insecure", "-s", $src;
	}
	elsif (defined \&Rollout::_open_http)
	{
	    $fd = _open_http($src);
	}
	else
	{
	    die "No HTTP support available (wget/curl)\n";
	}
    }

    unless ($fd)
    {
	unless (open $fd, $src)
	{
	    warning "Error opening $src: $!\n";
	    return wantarray ? ("", undef) : "";
	}
    }

    if ($other->{filter})
    {
	my $filter_fd;

	if (not open $filter_fd, "-|")
	{
	    $other->{filter} = [ $other->{filter} ]
		unless ref $other->{filter} eq 'ARRAY';
	    open STDIN, "<&=".fileno($fd);
	    exec @{ $other->{filter} };
	    die "Error executing filter '@{ $other->{filter} }': $!\n";
	}

	$fd = $filter_fd;
    }

    unless ($other->{eval})
    {
	local $/ = undef;
	my $txt = <$fd> || '';
	close $fd
	    or confess "Error reading: $!\n";
	return wantarray ? ($txt, 0) : $txt;
    }

    my $caller_package = (grep $_ ne __PACKAGE__, map +(caller $_)[0], 0..10)[0];

    $other->{eval} = eval "package $caller_package; sub { $other->{eval} }"
	unless ref $other->{eval} eq 'CODE';

    my $txt = '';
    my $changes = 0;
    local $_;

    my $pre = '';
    my $cmp = '';

    while (<$fd>)
    {
	$pre .= $_;
	my $match = $other->{eval}->($_);
	$cmp .= $_;

	next if $match;

	$changes = 1 unless $pre eq $cmp;
	$txt .= $cmp;
	$pre = $cmp = '';
    }

    if (length $pre)
    {
	$changes = 1 unless $pre eq $cmp;
	$txt .= $cmp;
	$pre = $cmp = '';
    }

    close $fd
	or confess "Error reading: $!\n";

    wantarray ? ($txt, $changes) : $txt;
}

sub set_attr
{
    my ($target, $mode, $uid, $gid, $other) = _args('dst|dest|destination mode owner|uid group|gid', @_)
	or return;

    for ($mode)
    {
	last unless defined;

	if (/^\d+$/)
	{
	    $mode = $_ & 07777;
	}
	elsif (/^([r-][w-][stx-]){3}$/)
	{
	    my @parts = /^(...)(...)(...)$/;
	    $mode = 0;
	    my $shift = 2;
	    foreach (@parts)
	    {
		$mode |= 1 <<  (9 + $shift)       if s/[st]/x/;
		$mode |= 1 << (($shift * 3) + 2)  if /r/;
		$mode |= 1 << (($shift * 3) + 1)  if /w/;
		$mode |= 1 <<  ($shift * 3)       if /x/;
		$shift--;
	    }
	}
	else
	{
	    warning "invalid mode %s", $_;
	    $mode = undef;
	}
    }

    for ($uid)
    {
	last unless defined;

	if (/^\d+$/)
	{
	    $uid = $_;
	}
	else
	{
	    unless (defined ($uid = getpwnam $_))
	    {
		warning "can't find user %s", $_;
		$uid = undef;
	    }
	}
    }

    for ($gid)
    {
	last unless defined;

	if (/^\d+$/)
	{
	    $gid = $_;
	}
	else
	{
	    unless (defined ($gid = getgrnam $_))
	    {
		warning "can't find group %s", $_;
		$gid = undef;
	    }
	}
    }

    return 0 unless defined $mode or defined $uid or defined $gid;

    my @stat = stat $target;

    unless (@stat)
    {
	# may not exist yet
	warning "can't stat %s: $!", $target unless $safe_mode;
	return 0;
    }

    my $changed = 0;

    if (defined $mode and ($stat[2] & 07777) != $mode)
    {
	note "Changing mode of %s to %04o", $target, $mode
	    unless $other->{quiet};

	$changed++;
	unless ($safe_mode)
	{
	    chmod $mode, $target
		or warning "chmod %04o %s failed: $!", $mode, $target;
	}
    }

    if (defined $uid and $stat[4] != $uid)
    {
	note "Changing owner of %s to %d", $target, $uid
	    unless $other->{quiet};

	$changed++;
    }
    else
    {
	$uid = -1;
    }

    if (defined $gid and $stat[5] != $gid)
    {
	note "Changing group of %s to %d", $target, $gid
	    unless $other->{quiet};

	$changed++;
    }
    else
    {
	$gid = -1;
    }

    if ($uid != -1 or $gid != -1)
    {
	unless ($safe_mode)
	{
	    chown $uid, $gid, $target
		or warning "chown %d:%d %s failed: $!", $uid, $gid, $target;
	}
    }

    return $changed;
}

sub dir_check
{
    my ($dir, $mode, $other) = _args('path|dir mode', @_)
	or return;

    confess "Path must be absolute: $dir\n"
	unless $dir =~ /^\//;

    $mode ||= 0755;

    my $changed = 0;

    unless (-e $dir)
    {
	# make parent if required
	(my $parent = $dir) =~ s!/[^/]+/?$!!;

	dir_check $parent, $mode, $other
	    if $parent and $parent ne $dir and !-e $parent;

	note "Creating directory %s with mode %04o", $dir, $mode
	    unless $other->{quiet};

	return 1 if $safe_mode;

	my $mask = umask 0;
	mkdir $dir, $mode or confess "can't create directory $dir: $!";
	umask $mask;

	$changed++;
    }
    else
    {
	confess "$dir is not a directory\n"
	    unless -d _;
    }

    (set_attr $dir, $mode, $other) || $changed;
}

sub dir_install
{
    my ($dst, $src, $cmd, $other) = _args('dst|dest|destination src|source cmd|command|run', @_)
	or return;

    (my $Qcmd, my $reload, $other) = _args('qcmd|queue_cmd|queue_command|run_queued reload', $other);

    opendir my $dir, $src or confess "Can't opendir '$src': $!";
    my @ent = grep !/^\.\.?$/, readdir $dir;
    closedir $dir;

    my $filter = $other->{filter} if ref $other->{filter} eq 'CODE';
    my $changed = 0;
    local $_;

    foreach (@ent)
    {
	next if $filter and not $filter->($dst, $src, $_);

	if (-d "$src/$_")
	{
	    $changed += dir_install "$dst/$_", "$src/$_", $other
		unless /^(?:CVS|RCS)$/;
	}
	else
	{
	    $changed += file_install "$dst/$_", "$src/$_", $other;
	}
    }

    if ($changed and $cmd)
    {
	$cmd = [ $cmd ] unless ref $cmd eq 'ARRAY';

        note "Running '%s' to finish install of %s", "@$cmd", $dst
	    unless $other->{quiet};

        command @$cmd, $other;
    }

    if ($changed and $Qcmd)
    {
	$Qcmd = [ $Qcmd ] unless ref $Qcmd eq 'ARRAY';

	note "Deferring '%s' to finish install of %s", "@$Qcmd", $dst
	    unless $other->{quiet};

	queue_command @$Qcmd, $other;
    }

    if ($changed and $reload)
    {
	note "Reloading '%s' to finish install of %s", $reload, $dst
	    unless $other->{quiet};

	reload_service $reload;
    }

    return $changed;
}

sub safe_write_file
{
    my ($dst, $src) = _args('dst|dest|destination src|source', @_)
	or return;

    return 1 if $safe_mode;

    open my $fh, ">$dst.$$"
	or confess "Unable to open $dst: $!";

    if (fileno $src)
    {
	local $_;

	while (<$src>)
	{
	    print $fh $_
		or confess "Unable to write $dst: $!";
	}
    }
    else
    {
	print $fh $src
	    or confess "Unable to write to $dst: $!";;
    }

    close $fh
	or confess "Unable to write to $dst: $!";

    rename "$dst.$$", $dst
	or confess "Unable to rename $dst.$$: $!";
}

sub safe_write
{
    my ($dst, $other) = _args('dst|dest|destination', @_)
	or return;

    return 1 if $safe_mode;

    unless (in_path('ci'))
    {
	confess "RCS not installed"
	    unless $other->{rcs_missing_ok};

	return safe_write_file $dst, $other;
    }

    my ($dir, $file) = $dst =~ m|^(?:(.*)/)?([^/]+)$|;
    $dir ||= ".";
    my $mode = (stat $dst)[2];
    my $rcs = "$dir/RCS/$file,v";

    if (-f "$dir/$file")
    {
	dir_check "$dir/RCS", 0700, -quiet => 1;

	command 'ci', '-q', '-mUntracked Changes', '-t-Initial Checkin', '-l', "$dir/$file";
	command 'rcs', '-q', '-ko', "$dir/$file";
    }

    safe_write_file $dst, $other;

    if (-f "$dir/$file")
    {
	dir_check "$dir/RCS", 0700, -quiet => 1;

	command 'ci', '-q', "-m".($other->{commit_msg} || $safe_write_msg), '-t-Initial checkin', '-l', "$dir/$file";
	command 'rcs', '-q', '-ko', "$dir/$file";
    }

    set_attr $dst, $other;

    return 1;
}

sub text_install
{
    my ($dst, $txt, $cmd, $other) = _args('dst|dest|destination txt|text cmd|command|run', @_)
	or return;

    (my $Qcmd, my $reload, $other) = _args('qcmd|queue_cmd|queue_command|run_queued reload', $other);

    # create containing directory if it doesn't exist
    (my $path = $dst) =~ s!/[^/]+$!!;
    dir_check $path;

    my $changed = 0;

    if (md5_hex($txt) ne md5_hex_file($dst))
    {
	note "Installing %s from %s", $dst, $other->{srcname} || "TEXT"
	    unless $other->{quiet};

	$changed += safe_write $dst, -src => $txt, $other;
    }

    $changed += set_attr $dst, $other;

    if ($changed and $cmd)
    {
	$cmd = [ $cmd ] unless ref $cmd eq 'ARRAY';

	note "Running '%s' to finish install of %s", "@$cmd", $dst
	    unless $other->{quiet};

	command @$cmd, $other;
    }

    if ($changed and $Qcmd)
    {
	$Qcmd = [ $Qcmd ] unless ref $Qcmd eq 'ARRAY';

	note "Deferring '%s' to finish install of %s", "@$Qcmd", $dst
	    unless $other->{quiet};

	queue_command @$Qcmd, $other;
    }

    if ($changed and $reload)
    {
	note "Reloading '%s' to finish install of %s", $reload, $dst
	    unless $other->{quiet};

	reload_service $reload;
    }

    $changed;
}

sub file_install
{
    my ($dst, $src, $other) = _args('dst|dest|destination src|source', @_)
	or return;

    return if $other->{once} and -e $dst;

    $other->{srcname} ||= $src;

    text_install $dst, $other,
	-txt => scalar slurp_file($src, $other);
}

sub file_append
{
    my ($dst, $add, $pat, $other) = _args('dst|dest|destination add|line|txt pat|pattern|pat_from|pattern_from', @_)
	or return;

    (my $pat_to, my $create, $other) = _args('pat_to|pattern_to create', $other);
    $pat = do { my $x = qr/$pat/; sub { /$x/../$pat_to/ } } if $pat_to;
    $pat = do { my $x = qr/$pat/; sub { /$x/ } } unless ref $pat eq "CODE";

    # special case, no $add can be used to remove lines
    if (length $add)
    {
	$add =~ s/\n?$/\n/;
	confess "Text '$add' doesn't match pattern\n"
	    unless grep($pat->(), split /\n/, $add);
    }

    my ($txt, $changed) = slurp_file $dst, $other,
	-eval => sub {
	    return unless $pat->();
	    ($_, $add) = ($add, '');
	    return 1;
	};

    unless ($changed)
    {
	return unless defined $changed or $create;
	return unless $add;
	$txt .= $add;
    }

    text_install $dst, $other,
	-txt => $txt;
}

sub file_modify
{
    my ($dst, $other) = _args('dst|dest|destination', @_)
	or return;

    my ($txt, $changed) = slurp_file $dst, $other;

    return unless $changed;

    text_install $dst, $other,
	-txt => $txt;
}

sub file_comment
{
    my ($dst, $pat, $other) = _args('dst|dest|destination pat|pattern', @_)
	or return;

    my @pat = ref $pat eq 'ARRAY' ? @$pat : $pat;

    text_install $dst, $other,
	-txt => scalar slurp_file($dst, $other, -eval => sub { s/^(?!\s*#)/#/ if grep $_[0] =~ /$_/, @pat });
}

sub file_uncomment
{
    my ($dst, $pat, $other) = _args('dst|dest|destination pat|pattern', @_)
	or return;

    my @pat = ref $pat eq 'ARRAY' ? @$pat : $pat;

    my $pref = qr/\(\?-[^:]*:/;
    my $anchor = qr/\^/;
    my $ws_pat = qr/(?:\\\s[\?\*\+]?|\s*)/;

    # make sure anchored patterns are prefixed by comment char ('\s*#\s*')
    s/^($pref?$anchor)(?!$ws_pat?#)/$1\\s*#\\s*/ foreach @pat;

    text_install $dst, $other,
	-txt => scalar slurp_file($dst, $other, -eval => sub { s/^(?:\s*#\s*)?// if grep $_[0] =~ /$_/, @pat });
}

sub symlink_check
{
    my ($src, $dst, $other) = _arg('src|source dst|dest|destination', @_)
	or return;

    if (-l $dst)
    {
	return 0 if (readlink $dst) eq $src;

	note "Changing target of symlink $dst to $src\n"
	    unless $other->{quiet};

	unless ($safe_mode)
	{
	    unlink $dst	or confess "can't unlink $dst: $!";
	    symlink $src, $dst or confess "can't symlink $src to $dst: $!";
	}

	return 1
    }

    confess "$dst is not a symlink" if -e _;

    note "Creating symlink $dst -> $src\n"
	unless $other->{quiet};

    unless ($safe_mode)
    {
	symlink $src, $dst or confess "can't symlink $src to $dst: $!";
    }

    return 1
}

sub x509_install
{
    my ($dst, $src, $other) = _args('dst|dest|destination src|source', @_)
	or return;

    file_install "$dst.enc", $src, -mode => 0600, -quiet => 1
	or !-e $dst
	or return;

    my $encrypted = (slurp_file "$dst.enc") =~ /\bENCRYPTED\b/;

    my $key = `openssl rsa -in "$dst.enc" 2>/dev/null`
	if $encrypted;

    file_install $dst, "$dst.enc", $other,
	$key ? (-eval => sub {
	    return unless /^-----BEGIN RSA PRIVATE KEY-----/../^-----END RSA PRIVATE KEY-----/;
	    ($_, $key) = ($key, '');
	    return 1;
	}) : ();
}

sub x509_cert
{
    my ($cert, $key, $other) = _args('crt|cert key', @_);

    # set defaults
    $other->{C}  ||= 'GB';
    $other->{ST} ||= 'Berkshire';
    $other->{L}  ||= 'Newbury';
    $other->{O}  ||= 'My Company Ltd';
    $other->{OU} ||= '';
    $other->{CN} ||= `hostname --fqdn`; chomp $other->{CN};
    $other->{validity} ||= 365;

    if (-f $key and -f $cert)
    {
	if (-M _ < ($other->{validity} - 21))
	{
	    my %cur = map m!^(\w+)=\s*/?(.*)!,
		`openssl x509 -in $cert -serial -subject -noout`;

	    my $new = join '/', map "$_=$other->{$_}", grep $other->{$_}, qw/C ST L O OU CN/;
	    # replace on subject mismatch or zero serial
	    return if $cur{subject} eq $new and $cur{serial} ne '00';
	}
    }

    note "Creating new X.509 certificate in $cert for CN=$other->{CN}\n";

    my $tmp_key = tmpnam;
    my $tmp_cert = tmpnam;
    my $serial = time;

    # generate new key
    open my $k, "| openssl req -new -x509 -keyout $tmp_key"
	. " -out $tmp_cert -days $other->{validity} -set_serial $serial"
	. " -passout pass:none"
	    or confess "can't fork 'openssl req': $!";

    confess "problem running 'openssl req': $?"
	unless print $k <<EOT and close $k;
$other->{C}
$other->{ST}
$other->{L}
$other->{O}
$other->{OU}
$other->{CN}
.
EOT

    unlink $cert, $key;
    system 'mv', $tmp_cert, $cert 
	and confess "can't rename $tmp_cert to $cert: $?";

    # remove the password
    system 'openssl', 'rsa', '-in', $tmp_key, '-out', $key, '-passin', 'pass:none'
	and confess "problem running 'openssl rsa': $?";

    unlink $tmp_key;
    return 1;
}

1;
